module Hscm.Primitive (primitiveEnv) where

import Hscm.Value
import Hscm.Parse(parse)
import qualified Data.Map as Map
import Control.Monad
import Control.Monad.Except
import Data.IORef
import System.IO


primitiveEnv :: IO HscmEnvRef
primitiveEnv = do
    let env = Map.fromList [
            ("+", PrimitiveProc $ numberOp (+)),
            ("-", PrimitiveProc $ numberOp (-)),
            ("*", PrimitiveProc $ numberOp (*)),
            ("/", PrimitiveProc $ numberOp (/)),
            ("//", PrimitiveProc $ integerOp div),
            ("mod", PrimitiveProc $ integerOp mod),
            ("quotient", PrimitiveProc $ integerOp quot),
            ("remainder", PrimitiveProc $ integerOp rem),
            ("=", PrimitiveProc $ numberBoolBinop (==)),
            ("<", PrimitiveProc $ numberBoolBinop (<)),
            (">", PrimitiveProc $ numberBoolBinop (>)),
            ("/=", PrimitiveProc $ numberBoolBinop (/=)),
            (">=", PrimitiveProc $ numberBoolBinop (>=)),
            ("<=", PrimitiveProc $ numberBoolBinop (<=)),
            ("&&", PrimitiveProc $ boolBoolBinop (&&)),
            ("||", PrimitiveProc $ boolBoolBinop (||)),
            ("string=?", PrimitiveProc $ strBoolBinop (==)),
            ("string<?", PrimitiveProc $ strBoolBinop (<)),
            ("string>?", PrimitiveProc $ strBoolBinop (>)),
            ("string<=?", PrimitiveProc $ strBoolBinop (<=)),
            ("string>=?", PrimitiveProc $ strBoolBinop (>=)),
            ("car", PrimitiveProc $ car),
            ("cdr", PrimitiveProc $ cdr),
            ("cons", PrimitiveProc $ cons),
            ("eq?", PrimitiveProc $ eqv),
            ("eqv?", PrimitiveProc $ eqv),
            ("equal?", PrimitiveProc $ equal),
            
            ("open-input-file", IOPrimitiveProc $ makePort ReadMode),
            ("open-output-file", IOPrimitiveProc $ makePort WriteMode),
            ("close-input-port", IOPrimitiveProc $ closePort),
            ("close-output-port", IOPrimitiveProc $ closePort),
            ("read", IOPrimitiveProc $ readProc),
            ("write", IOPrimitiveProc $ writeProc),
            ("read-contents", IOPrimitiveProc $ readContentsProc),
            ("display", IOPrimitiveProc $ displayProc),
            ("newline", IOPrimitiveProc $ newlineProc),
            ("flush-output-port", IOPrimitiveProc $ flushPortProc)]
    newIORef $ HscmEnv env Nothing


numberOp :: (HscmNumber -> HscmNumber -> HscmNumber) -> [HscmValue] -> HscmResult HscmValue
numberOp op           []  = throwError $ NumArgs 2 []
numberOp op singleVal@[_] = throwError $ NumArgs 2 singleVal
numberOp op params = mapM unpackNumber params >>= return . packNumber . foldl1 op


integerOp :: (Integer -> Integer -> Integer) -> [HscmValue] -> HscmResult HscmValue
integerOp op           []  = throwError $ NumArgs 2 []
integerOp op singleVal@[_] = throwError $ NumArgs 2 singleVal
integerOp op params = mapM unpackInteger params >>= return . Integer . foldl1 op


numberBoolBinop  = boolBinop unpackNumber
strBoolBinop     = boolBinop unpackStr
boolBoolBinop    = boolBinop unpackBool


boolBinop :: (HscmValue -> HscmResult a) -> (a -> a -> Bool) -> [HscmValue] -> HscmResult HscmValue
boolBinop unpacker op args = if length args /= 2 
    then throwError $ NumArgs 2 args
    else do 
        left <- unpacker $ args !! 0
        right <- unpacker $ args !! 1
        return $ Bool $ left `op` right


unpackNumber :: HscmValue -> HscmResult HscmNumber
unpackNumber (Integer n) = return $ IntegerNumber n
unpackNumber (Double  n) = return $ DoubleNumber n
unpackNumber notNum      = throwError $ TypeMismatch "integer/double" notNum

unpackInteger :: HscmValue -> HscmResult Integer
unpackInteger (Integer n) = return n
unpackInteger notNum = throwError $ TypeMismatch "number" notNum

unpackStr :: HscmValue -> HscmResult String
unpackStr (String s) = return s
unpackStr notStr = throwError $ TypeMismatch "string" notStr

unpackBool :: HscmValue -> HscmResult Bool
unpackBool (Bool b) = return b
unpackBool notBool = throwError $ TypeMismatch "boolean" notBool

packNumber :: HscmNumber -> HscmValue
packNumber (IntegerNumber n) = Integer n
packNumber (DoubleNumber  n) = Double  n


data HscmNumber = IntegerNumber Integer
                | DoubleNumber  Double

instance Eq HscmNumber where
    (IntegerNumber i1) == (IntegerNumber i2) = i1 == i2
    (DoubleNumber  d1) == (DoubleNumber  d2) = d1 == d2
    (IntegerNumber  i) == (DoubleNumber   d) = (fromInteger i) == d
    (DoubleNumber   d) == (IntegerNumber  i) = (fromInteger i) == d

instance Ord HscmNumber where
    compare (IntegerNumber i1) (IntegerNumber i2) = compare i1 i2
    compare (DoubleNumber  d1) (DoubleNumber  d2) = compare d1 d2
    compare (IntegerNumber  i) (DoubleNumber   d) = compare (fromInteger i) d
    compare (DoubleNumber   d) (IntegerNumber  i) = compare (fromInteger i) d

instance Num HscmNumber where
    (IntegerNumber i1) + (IntegerNumber i2) = IntegerNumber (i1 + i2)
    (DoubleNumber  d1) + (DoubleNumber  d2) = DoubleNumber  (d1 + d2)
    (IntegerNumber  i) + (DoubleNumber   d) = DoubleNumber  ((fromInteger i) + d)
    (DoubleNumber   d) + (IntegerNumber  i) = DoubleNumber  ((fromInteger i) + d)

    (IntegerNumber i1) - (IntegerNumber i2) = IntegerNumber (i1 - i2)
    (DoubleNumber  d1) - (DoubleNumber  d2) = DoubleNumber  (d1 - d2)
    (IntegerNumber  i) - (DoubleNumber   d) = DoubleNumber  ((fromInteger i) - d)
    (DoubleNumber   d) - (IntegerNumber  i) = DoubleNumber  ((fromInteger i) - d)

    (IntegerNumber i1) * (IntegerNumber i2) = IntegerNumber (i1 * i2)
    (DoubleNumber  d1) * (DoubleNumber  d2) = DoubleNumber  (d1 * d2)
    (IntegerNumber  i) * (DoubleNumber   d) = DoubleNumber  ((fromInteger i) * d)
    (DoubleNumber   d) * (IntegerNumber  i) = DoubleNumber  ((fromInteger i) * d)

    abs (IntegerNumber i) = IntegerNumber (abs i)
    abs (DoubleNumber  d) = DoubleNumber  (abs d)

    signum (IntegerNumber i) = IntegerNumber (signum i)
    signum (DoubleNumber  d) = DoubleNumber  (signum d)

    fromInteger = undefined 

instance Fractional HscmNumber where
    (IntegerNumber i1) / (IntegerNumber i2) = DoubleNumber ((fromInteger i1) / (fromInteger i2))
    (DoubleNumber  d1) / (DoubleNumber  d2) = DoubleNumber (d1 / d2)
    (IntegerNumber  i) / (DoubleNumber   d) = DoubleNumber ((fromInteger i) / d)
    (DoubleNumber   d) / (IntegerNumber  i) = DoubleNumber ((fromInteger i) / d)

    fromRational = undefined 


car :: [HscmValue] -> HscmResult HscmValue
car [List (x : xs)]         = return x
car [DottedList (x : xs) _] = return x
car [badArg]                = throwError $ TypeMismatch "pair" badArg
car badArgList              = throwError $ NumArgs 1 badArgList


cdr :: [HscmValue] -> HscmResult HscmValue
cdr [List (x : xs)]         = return $ List xs
cdr [DottedList [_] x] = return x
cdr [DottedList (_ : xs) x] = return $ DottedList xs x
cdr [badArg]                = throwError $ TypeMismatch "pair" badArg
cdr badArgList              = throwError $ NumArgs 1 badArgList


cons :: [HscmValue] -> HscmResult HscmValue
cons [x1, List []]            = return $ List [x1]
cons [x, List xs]             = return $ List $ x : xs
cons [x, DottedList xs xlast] = return $ DottedList (x : xs) xlast
cons [x1, x2]                 = return $ DottedList [x1] x2
cons badArgList = throwError $ NumArgs 2 badArgList


eqv :: [HscmValue] -> HscmResult HscmValue
eqv [(Bool arg1), (Bool arg2)]             = return $ Bool $ arg1 == arg2 
eqv [(Integer arg1), (Integer arg2)]         = return $ Bool $ arg1 == arg2 
eqv [(String arg1), (String arg2)]         = return $ Bool $ arg1 == arg2 
eqv [(Symbol arg1), (Symbol arg2)]             = return $ Bool $ arg1 == arg2 
eqv [(DottedList xs x), (DottedList ys y)] = eqv [List $ xs ++ [x], List $ ys ++ [y]]
eqv [(List arg1), (List arg2)]             = return $ Bool $ (length arg1 == length arg2) && 
                                                             (all eqvPair $ zip arg1 arg2)
    where 
        eqvPair (x1, x2) = case eqv [x1, x2] of 
            Left err -> False
            Right (Bool val) -> val
eqv [_, _]                                 = return $ Bool False
eqv badArgList                             = throwError $ NumArgs 2 badArgList


equal :: [HscmValue] -> HscmResult HscmValue
equal = undefined


{-
    liftM :: Monad m => (a1 -> r) -> m a1 -> m r
    liftIO :: IO a -> m a
    
    openFile :: FilePath -> IOMode -> IO Handle
    liftIO :: IO Handle -> HscmIOResult Handle

    (a1 -> r) :: (Handle -> HscmValue)
    liftM :: (Handle -> HscmValue) -> HscmIOResult Handle -> HscmIOResult HscmValue
-}
makePort :: IOMode -> [HscmValue] -> HscmIOResult HscmValue
makePort mode [String filename] = liftM Port $ liftIO $ openFile filename mode
makePort mode [badArg]          = throwError $ TypeMismatch "string" badArg
makePort mode badArgList        = throwError $ NumArgs 1 badArgList

{-
    hClose :: Handle -> IO ()
    liftIO :: IO a -> m a
-}
closePort :: [HscmValue] -> HscmIOResult HscmValue
closePort [Port port] = liftIO $ hClose port >> (return $ Bool True)
closePort [badArg]    = throwError $ TypeMismatch "port" badArg
closePort badArgList  = throwError $ NumArgs 1 badArgList

{-
    liftThrows :: MonadError e m => Either e a -> m a
    parse :: String -> HscmResult HscmValue
    hGetLine :: Handle -> IO String
-}
readProc :: [HscmValue] -> HscmIOResult HscmValue
readProc [Port port] = (liftIO $ hGetLine port) >>= (\s -> resultToIOResult $ parse s)
readProc []          = readProc [Port stdin]
readProc [badArg]    = throwError $ TypeMismatch "port" badArg
readProc badArgList  = throwError $ NumArgs 1 badArgList


writeProc :: [HscmValue] -> HscmIOResult HscmValue
writeProc [value, Port port] = liftIO $ hPutStr port (reprValue value) >> (return $ Bool True)
writeProc [value]            = writeProc [value, Port stdout]
writeProc badArgList         = throwError $ NumArgs 1 badArgList


-- readFile :: FilePath -> IO String
readContentsProc :: [HscmValue] -> HscmIOResult HscmValue
readContentsProc [String filename] = liftM String $ liftIO $ readFile filename
readContentsProc [Port port]       = (liftIO $ hGetLine port) >>= (\s -> return $ String s)
readContentsProc [badArg]          = throwError $ TypeMismatch "stirng / port" badArg
readContentsProc badArgList        = throwError $ NumArgs 1 badArgList


displayProc :: [HscmValue] -> HscmIOResult HscmValue
displayProc [value, Port port] = liftIO $ hPutStr port (strValue value) >> (return $ Bool True)
displayProc [value]            = displayProc [value, Port stdout]
displayProc badArgList         = throwError $ NumArgs 1 badArgList


newlineProc :: [HscmValue] -> HscmIOResult HscmValue
newlineProc [Port port] = liftIO $ hPutStr port "\n" >> (return $ Bool True)
newlineProc []          = newlineProc [Port stdout]


flushPortProc :: [HscmValue] -> HscmIOResult HscmValue
flushPortProc [Port port] = liftIO $ hFlush port >> (return $ Bool True)
flushPortProc []          = flushPortProc [Port stdout]
flushPortProc [badArg]    = throwError $ TypeMismatch "port" badArg
flushPortProc badArgList  = throwError $ NumArgs 1 badArgList